home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC2.6 / M2CM.MOD < prev    next >
Encoding:
Modula Implementation  |  1992-05-29  |  21.0 KB  |  650 lines  |  [TEXT/MEDT]
  1. IMPLEMENTATION MODULE M2CM; (* HS 19.4.85 / 10.6.86 / 29.2.92; WH 9.5.85 *)
  2.  
  3.   FROM SYSTEM IMPORT
  4.     WORD, VAL;
  5.   FROM M2DM IMPORT
  6.     WordSize, MaxInt, MaxDouble, ObjPtr, StrPtr, ParPtr, PDPtr,
  7.     Standard, ObjClass, StrForm, PDesc, Object, ovflchk,
  8.     notyp, undftyp, booltyp, chartyp, cardtyp, cardinttyp, inttyp,
  9.     bitstyp,  lcardtyp, dbltyp, realtyp, lrltyp, proctyp, stringtyp,
  10.     addrtyp,  wordtyp, bytetyp;
  11.   FROM M2SM IMPORT
  12.     Mark;
  13.   FROM M2HM IMPORT
  14.     D0, D1, SB, MP, SP,
  15.     byte, word, long,
  16.     Condition, RegType, Register, WidType, ItemMode, Item,
  17.     LongVal, WordVal, SimpleT, RealT,
  18.     GetReg, Release, ReleaseReg, SetbusyReg, SaveRegs, RestoreRegs,
  19.     SetlocMd, SetregMd, SetstkMd, SetconMd,
  20.     StackTop, SetupSL, GenHalt,
  21.     LoadD, LoadP, LoadX, Move, MoveAdr, MoveBlock, Tst1, Add2, Cmp2,
  22.     CheckClimit, CheckRange, CheckDbltoSingle, DynArray,
  23.     Jf, Jb, EnterCase, ExitCase, Link, Unlink, CallInt, CallExt, CallInd,
  24.     EnterModule, ExitModule, InitModule,
  25.     FMove, LoadF, FMonad;
  26.   FROM M2LM IMPORT
  27.     pc, maxP, maxM, PutWord, AllocChar, FixLink, FixLinkWith, fixup;
  28.   FROM M2EM IMPORT
  29.     GlbParStartAdr, LocParStartAdr;
  30.  
  31.  
  32.   VAR sp0, sp : INTEGER;
  33.  
  34.  
  35.   PROCEDURE err(n: CARDINAL);
  36.     (* local synonym for M2SM.Mark to save space! *)
  37.   BEGIN
  38.     Mark(n);
  39.   END err;
  40.  
  41.   PROCEDURE Put16(w : WORD);
  42.     (* local synonym for M2LM.PutWord to save space! *)
  43.   BEGIN
  44.     PutWord(w);
  45.   END Put16;
  46.  
  47.   PROCEDURE SRTest(VAR x : Item);
  48.   BEGIN
  49.     WITH x DO
  50.       IF typ^.form = Range THEN typ := typ^.RBaseTyp END;
  51.     END (*WITH*);
  52.   END SRTest;
  53.  
  54.   PROCEDURE setCC(VAR x : Item; fcc : Condition);
  55.     (* transform all modes to 'cocMd' : *)
  56.   BEGIN
  57.     Release(x);
  58.     WITH x DO
  59.       typ := booltyp; mode := cocMd; CC := fcc;
  60.       Tjmp := 0; Fjmp := 0;
  61.     END;
  62.   END setCC;
  63.  
  64.   PROCEDURE GenAssign(VAR x, y : Item);
  65.     (*       x    :=    y     *)
  66.     (*       y  ---->>  x     *)
  67.     (* or    g  ---->>  f     *)
  68.     VAR f, g, h : StrForm;
  69.         xp, yp : ParPtr;
  70.         x0, y0 : Item;
  71.         Dn : Register;
  72.         s, sadr : INTEGER;
  73.         L : CARDINAL;
  74.         sz : WidType;
  75.         xt : StrPtr;
  76.   BEGIN
  77.     IF (x.mode = conMd) OR (x.mode > stkMd) THEN err(134) END;
  78.     SRTest(y);
  79.     f := x.typ^.form;
  80.     h := f; (* holds original form of x during GenAssign *)
  81.     g := y.typ^.form;
  82.     IF f = Range THEN
  83.       (* perform range check. *)
  84.       WITH x DO
  85.         IF y.mode = conMd THEN
  86.           IF (WordVal(y) < typ^.min) OR
  87.              (WordVal(y) > typ^.max) THEN
  88.             err(138)
  89.           END
  90.         ELSE
  91.           CheckRange(y, typ^.min, typ^.max, typ^.BndAdr);
  92.         END;
  93.         typ := typ^.RBaseTyp;
  94.         f := typ^.form;
  95.       END (*WITH*);
  96.     END (*f = Range*);
  97.     xt := x.typ; (* hold original type of x *)
  98.  
  99.     CASE f (* destination form *) OF
  100.  
  101.       Undef :    IF ((x.typ = wordtyp) & (y.typ^.size = 2)) OR
  102.                     ((x.typ = bytetyp) & (y.typ^.size = 1)) THEN
  103.                    Move(y,x)
  104.                  ELSE err(133)
  105.                  END;
  106.  
  107.     | Bool :     IF g = Bool THEN Move(y,x)
  108.                  ELSE err(133)
  109.                  END;
  110.  
  111.     | Char :     IF g = Char THEN Move(y,x)
  112.                  ELSE err(133)
  113.                  END;
  114.  
  115.     | Card :     IF (g = Card) OR (g = CardInt) THEN Move(y,x)
  116.                  ELSIF g = Int THEN
  117.                    IF y.mode = conMd THEN
  118.                      IF y.val.I < 0 THEN err(132) END;
  119.                    ELSE (* emit check *)
  120.                      IF h <> Range THEN CheckClimit(y, MaxInt) END;
  121.                    END;
  122.                    Move(y,x)
  123.                  ELSIF (g = Double) OR (g = LCard) THEN
  124.                    LoadD(y); (* must be loaded long! *)
  125.                    CheckDbltoSingle(y,x); (* emit check *)
  126.                    y.typ := x.typ;
  127.                    Move(y,x)
  128.                  ELSE err(133)
  129.                  END;
  130.  
  131.     | Int :      IF (g = Int) OR (g = CardInt) THEN Move(y,x)
  132.                  ELSIF g = Card THEN
  133.                    IF y.mode = conMd THEN
  134.                      IF y.val.C > MaxInt THEN err(208) END;
  135.                    ELSE (* emit check *)
  136.                      IF h <> Range THEN CheckClimit(y, MaxInt) END;
  137.                    END;
  138.                    Move(y,x)
  139.                  ELSIF (g = Double) OR (g = LCard) THEN
  140.                    LoadD(y); (* must be loaded long! *)
  141.                    CheckDbltoSingle(y,x); (* emit check *)
  142.                    y.typ := x.typ;
  143.                    Move(y,x)
  144.                  ELSE err(133)
  145.                  END;
  146.  
  147.     | Double :   IF g = Double THEN Move(y,x)
  148.                  ELSIF (g = LCard) & (y.typ # addrtyp) THEN
  149.                    IF y.mode = conMd THEN
  150.                      (* genuine LONGCARD-constant : *)
  151.                      IF y.val.D < 0D THEN err(217) END;
  152.                    ELSE (* emit check *)
  153.                      CheckClimit(y, MaxDouble);
  154.                    END;
  155.                    Move(y,x)
  156.                  ELSIF (g = Int) OR (g = Card) OR (g = CardInt) THEN
  157.                    IF y.mode = conMd THEN
  158.                      SetconMd(y, LongVal(y), dbltyp);
  159.                    ELSE
  160.                      LoadX(y,long); y.typ := dbltyp;
  161.                    END;
  162.                    Move(y,x)
  163.                  ELSIF y.typ = addrtyp THEN Move(y,x)
  164.                  ELSE err(133)
  165.                  END;
  166.  
  167.     | LCard :    IF g = LCard THEN Move(y,x)
  168.                  ELSIF g = Double THEN
  169.                    IF y.mode = conMd THEN
  170.                      (* no check! allow all double constants, *)
  171.                      (* because scanner delivers all these    *)
  172.                      (* long constants of type LONGINT, even  *)
  173.                      (* values such as 0FFFFFFFFH etc.        *)
  174.                    ELSE (* emit check for genuine LCard only! *)
  175.                      IF (xt = lcardtyp) THEN
  176.                        CheckClimit(y, MaxDouble);
  177.                      END;
  178.                    END;
  179.                    Move(y,x)
  180.                  ELSIF (g = Int) OR (g = Card) OR (g = CardInt) THEN
  181.                    (* emit checks for genuine LCard only! *)
  182.                    IF y.mode = conMd THEN
  183.                      IF (xt = lcardtyp) & (g = Int) THEN
  184.                        IF y.val.I < 0 THEN err(218) END;
  185.                      END;
  186.                      SetconMd(y, LongVal(y), x.typ);
  187.                    ELSE
  188.                      LoadX(y,long); y.typ := x.typ;
  189.                      IF (xt = lcardtyp) & (g = Int) THEN
  190.                        CheckClimit(y, MaxInt);
  191.                      END;
  192.                    END;
  193.                    Move(y,x)
  194.                  ELSIF (xt = addrtyp) & (g = Pointer) THEN Move(y,x)
  195.                  ELSE err(133)
  196.                  END;
  197.  
  198.     | Real :     IF g = Real THEN FMove(y,x)
  199.                  ELSIF g = LongReal THEN
  200.                    FMonad(Short,y);
  201.                    y.typ := x.typ;
  202.                    FMove(y,x)
  203.                  ELSE err(133)
  204.                  END;
  205.  
  206.     | LongReal : IF g = LongReal THEN FMove(y,x)
  207.                  ELSIF g = Real THEN
  208.                    FMonad(Long,y);
  209.                    y.typ := x.typ;
  210.                    FMove(y,x)
  211.                  ELSE err(133)
  212.                  END;
  213.  
  214.     | Enum :     IF x.typ = y.typ THEN Move(y,x)
  215.                  ELSE err(133)
  216.                  END;
  217.  
  218.     | Set :      IF x.typ = y.typ THEN Move(y,x)
  219.                  ELSE err(133)
  220.                  END;
  221.  
  222.     | Pointer :  IF (x.typ = y.typ) OR (y.typ = addrtyp) THEN
  223.                    Move(y,x)
  224.                  ELSE err(133)
  225.                  END;
  226.  
  227.     | Opaque :   IF (x.typ = y.typ) THEN Move(y,x)
  228.                  ELSE err(133)
  229.                  END;
  230.  
  231.     | Record :   IF x.typ = y.typ THEN
  232.                    s := x.typ^.size;
  233.                    MoveBlock(y,x,s,FALSE)
  234.                  ELSE err(133)
  235.                  END;
  236.  
  237.     | ProcTyp :  IF y.mode = procMd THEN
  238.                    (* procedure-constant to procedure-variable : *)
  239.                    IF y.proc^.pd^.lev <> 0 THEN err(127)
  240.                    ELSIF x.typ^.resTyp <> y.proc^.typ THEN err(128)
  241.                    ELSE xp := x.typ^.firstPar; yp := y.proc^.firstParam;
  242.                      WHILE xp <> NIL DO
  243.                        IF yp <> NIL THEN
  244.                          IF (xp^.varpar <> yp^.varpar) OR
  245.                             ((xp^.typ <> yp^.typ) AND
  246.                             ((xp^.typ^.form <> Array) OR
  247.                              NOT xp^.typ^.dyn OR
  248.                              (yp^.typ^.form <> Array) OR
  249.                              NOT yp^.typ^.dyn OR
  250.                              (xp^.typ^.ElemTyp <> yp^.typ^.ElemTyp))) THEN
  251.                            err(129)
  252.                          END;
  253.                          yp := yp^.next
  254.                        ELSE err(130)
  255.                        END;
  256.                        xp := xp^.next
  257.                      END (*WHILE*);
  258.                      IF yp <> NIL THEN err(131) END;
  259.                      MoveAdr(y,x);
  260.                    END;
  261.                  ELSIF x.typ = y.typ THEN Move(y,x)
  262.                  ELSE err(133)
  263.                  END;
  264.  
  265.     | Array :    s := x.typ^.size;
  266.                  IF (x.typ = y.typ) & NOT(x.typ^.dyn) THEN
  267.                    MoveBlock(y,x,s,FALSE)
  268.                  ELSIF (x.mode = stkMd) & x.typ^.dyn THEN
  269.                    (* formal parameter is dynamic array : *)
  270.                    IF (g = Array) & (x.typ^.ElemTyp = y.typ^.ElemTyp) THEN
  271.                      DynArray(x,y)
  272.                    ELSE
  273.                      IF (x.typ^.ElemTyp = chartyp) OR
  274.                         (x.typ^.ElemTyp = bytetyp) THEN
  275.                        IF g = String THEN
  276.                          DynArray(x,y)
  277.                        ELSIF (g = Char) & (y.mode = conMd) THEN
  278.                          (* character-constant to dynamic array : *)
  279.                          AllocChar(y.val.Ch, sadr);
  280.                          WITH y DO
  281.                            typ := stringtyp; val.D0 := sadr; val.D1 := 1;
  282.                          END (*WITH*);
  283.                          DynArray(x,y)
  284.                        ELSIF (x.typ^.ElemTyp = bytetyp) THEN DynArray(x,y)
  285.                        ELSE err(133)
  286.                        END
  287.                      ELSE err(133)
  288.                      END
  289.                    END
  290.                  ELSIF x.typ^.ElemTyp = chartyp THEN
  291.                    IF x.typ^.dyn THEN err(143) END;
  292.                    IF x.typ^.IndexTyp # NIL THEN
  293.                      WITH x.typ^.IndexTyp^ DO
  294.                        IF form = Range THEN s := max - min + 1 END;
  295.                      END;
  296.                    END;
  297.                    IF g = String THEN
  298.                      (* string to fixed-size array : *)
  299.                      (* check length of string.      *)
  300.                      IF y.val.D1 > s THEN err(146) END;
  301.                      MoveBlock(y,x,s,TRUE);
  302.                    ELSIF (g = Char) & (y.mode = conMd) THEN
  303.                      (* character-constant to fixed-size array : *)
  304.                      AllocChar(y.val.Ch, sadr);
  305.                      WITH y DO
  306.                        typ := stringtyp; val.D0 := sadr; val.D1 := 1;
  307.                      END (*WITH*);
  308.                      MoveBlock(y,x,s,TRUE);
  309.                    ELSE err(133)
  310.                    END
  311.                  ELSE err(133)
  312.                  END;
  313.  
  314.     ELSE (* must not occur on the left side *)
  315.       err(133)
  316.     END (*CASE f*);
  317.     x.typ := xt; (* restore original type of x *)
  318.     Release(y);
  319.     Release(x);
  320.   END GenAssign;
  321.  
  322.   PROCEDURE GenFJ(VAR loc: CARDINAL);
  323.   BEGIN
  324.     Jf(T, loc);
  325.   END GenFJ;
  326.  
  327.   PROCEDURE GenCFJ(VAR x: Item; VAR loc: CARDINAL);
  328.   BEGIN
  329.     IF x.typ = booltyp THEN
  330.       IF x.mode <> cocMd THEN Tst1(x); setCC(x, EQ) END;
  331.     ELSE
  332.       setCC(x, EQ); err(135);  (* type of expression must be boolean *)
  333.     END;
  334.     loc := x.Fjmp; Jf(x.CC, loc); FixLink(x.Tjmp);
  335.   END GenCFJ;
  336.  
  337.   PROCEDURE GenBJ(loc: CARDINAL);
  338.   BEGIN
  339.     Jb(T, loc);
  340.   END GenBJ;
  341.  
  342.   PROCEDURE GenCBJ(VAR x: Item; loc: CARDINAL);
  343.   BEGIN
  344.     IF x.typ = booltyp THEN
  345.       IF x.mode <> cocMd THEN Tst1(x); setCC(x, EQ) END;
  346.     ELSE
  347.       setCC(x, EQ); err(135); (* type of expression must be boolean *)
  348.     END;
  349.     Jb(x.CC, loc); FixLinkWith(x.Fjmp, loc); FixLink(x.Tjmp);
  350.   END GenCBJ;
  351.  
  352.   PROCEDURE SpaceForFunction(func : StrPtr);
  353.     (* reserve space on top of stack for function result. *)
  354.     VAR sz : CARDINAL; tos : Item;
  355.   BEGIN
  356.     sz := VAL(CARDINAL,func^.size);
  357.     SetstkMd(tos, func);
  358.     IF SimpleT(tos) OR RealT(tos) OR (sz IN {1,2,4,8}) THEN
  359.       StackTop( - func^.size );
  360.     ELSE
  361.       err(200); (* this function result size not implemented! *)
  362.     END;
  363.   END SpaceForFunction;
  364.  
  365.   PROCEDURE PrepCall(VAR x: Item; VAR fp: ParPtr; VAR regs: LONGINT);
  366.     VAR func: StrPtr; Rn: Register;
  367.   BEGIN
  368.     Rn := 0;
  369.     WITH x DO
  370.       IF (mode = procMd) OR (mode = codMd) THEN
  371.         func := proc^.typ; fp := proc^.firstParam;
  372.       ELSIF typ^.form = ProcTyp THEN
  373.         func := typ^.resTyp; fp := typ^.firstPar;
  374.         LoadP(x);                 (* load procedure variable *)
  375.         Rn := R; ReleaseReg(Rn);  (* inhibit save of register Rn *)
  376.       ELSE
  377.         func := notyp; fp := NIL;
  378.         err(136); (* call of an object which is not a procedure *)
  379.       END;
  380.       SaveRegs(regs);
  381.       IF Rn <> 0 THEN SetbusyReg(Rn) END;  (* re-reserve register Rn *)
  382.       IF func <> notyp THEN SpaceForFunction(func) END;
  383.     END (*WITH*);
  384.   END PrepCall;
  385.  
  386.   PROCEDURE GenParam(VAR ap: Item; f: ParPtr);
  387.     VAR fp: Item;
  388.   BEGIN
  389.     SetstkMd(fp, f^.typ);
  390.     IF f^.varpar THEN
  391.       IF (fp.typ^.form = Array) & fp.typ^.dyn & (fp.typ^.ElemTyp = bytetyp) THEN
  392.         DynArray(fp, ap);
  393.       ELSIF (fp.typ^.form = Array) & fp.typ^.dyn &
  394.             (ap.typ^.form = Array) & (ap.typ^.ElemTyp = fp.typ^.ElemTyp) THEN
  395.         DynArray(fp, ap);
  396.       ELSIF (ap.typ = fp.typ) OR
  397.         (fp.typ = wordtyp) & (ap.typ^.size = 2) OR
  398.         (fp.typ = bytetyp) & (ap.typ^.size = 1) OR
  399.         (fp.typ = addrtyp) & (ap.typ^.form = Pointer) THEN
  400.         IF (ap.mode = procMd) & (f^.typ^.form # ProcTyp) THEN
  401.           err(137)
  402.         ELSE
  403.           MoveAdr(ap, fp)
  404.         END;
  405.       ELSE
  406.         err(137); (* type of VAR par is not identical to that of actual par *)
  407.       END;
  408.     ELSE
  409.       GenAssign(fp, ap); (* type check in GenAssign *)
  410.     END;
  411.     Release(ap);
  412.   END GenParam;
  413.  
  414.   PROCEDURE RestoreResultAndRegs(VAR x : Item; regs : LONGINT);
  415.     VAR y, z : Item; sz : CARDINAL;
  416.   BEGIN
  417.     WITH x DO
  418.       SetstkMd(x, typ);   (* result on top of stack *)
  419.       IF regs <> 0D THEN  (* saved registers above result *)
  420.         (* Caution: saved registers remain busy, so the LoadD(x) *)
  421.         (* -------  below gets a pool-register which is NOT in   *)
  422.         (*          the set of the registers to be restored.     *)
  423.         IF SimpleT(x) THEN LoadD(x)
  424.         ELSIF RealT(x) THEN LoadF(x)
  425.         ELSE (* structured type *)
  426.           sz := VAL(CARDINAL,typ^.size);
  427.           IF NOT(sz IN {1,2,4,8}) THEN
  428.             err(200); (* function result size not implemented! *)
  429.           ELSE
  430.             IF sz IN {1,2,4} THEN (* byte/word/long result *)
  431.               SetstkMd(z, typ);
  432.               SetregMd(y, D0, typ); Move(z,y);
  433.               RestoreRegs(regs); regs := 0D;
  434.               Move(y,z);
  435.             ELSE (* double-longword result *)
  436.               SetstkMd(z, dbltyp);
  437.               SetregMd(y, D0, dbltyp); Move(z,y);
  438.               SetregMd(y, D1, dbltyp); Move(z,y);
  439.               RestoreRegs(regs); regs := 0D;
  440.               SetregMd(y, D1, dbltyp); Move(y,z);
  441.               SetregMd(y, D0, dbltyp); Move(y,z);
  442.             END;
  443.           END;
  444.         END;
  445.         RestoreRegs(regs);
  446.       END (*regs*);
  447.     END (*WITH*);
  448.   END RestoreResultAndRegs;
  449.  
  450.   PROCEDURE GenCall(VAR x: Item; regs: LONGINT);
  451.     VAR pd: PDPtr; y, z: Item;
  452.   BEGIN
  453.     WITH x DO
  454.       IF mode = procMd THEN
  455.         pd := proc^.pd;
  456.         IF pd^.adr <> 0 THEN (* module internal call *)
  457.           IF pd^.lev > 0 THEN SetupSL(pd^.lev) END;
  458.           CallInt(proc);
  459.         ELSE (* external call *)
  460.           CallExt(proc);
  461.         END;
  462.         typ := proc^.typ;
  463.       ELSIF mode = codMd THEN
  464.         Put16(proc^.cnum); typ := proc^.typ;
  465.       ELSIF (mode <= DregMd) & (typ <> undftyp) & (typ^.form = ProcTyp) THEN
  466.         CallInd(x); typ := typ^.resTyp;
  467.       END;
  468.       IF typ <> notyp THEN (* function call *)
  469.         RestoreResultAndRegs(x,regs)
  470.       ELSE (* procedure call *)
  471.         RestoreRegs(regs)
  472.       END;
  473.     END (*WITH*);
  474.   END GenCall;
  475.  
  476.   PROCEDURE GenEnter(VAR l: CARDINAL; lev: CARDINAL);
  477.   BEGIN
  478.     Link(l, lev); sp := 0; sp0 := 0;
  479.   END GenEnter;
  480.  
  481.   PROCEDURE GenResult(VAR x: Item; proc: ObjPtr; VAR l: CARDINAL);
  482.     VAR res: Item; resadr : INTEGER;
  483.   BEGIN
  484.     IF x.typ <> notyp THEN (* function *)
  485.       IF proc^.pd^.lev > 0 THEN
  486.         resadr := LocParStartAdr + proc^.pd^.size
  487.       ELSE
  488.         resadr := GlbParStartAdr + proc^.pd^.size
  489.       END;
  490.       SetlocMd(res, resadr, proc^.typ);
  491.       GenAssign(res, x);
  492.     END;
  493.     StackTop(sp - sp0);
  494.     GenFJ(l);
  495.   END GenResult;
  496.  
  497.   PROCEDURE GenReturn(proc: ObjPtr; l: CARDINAL);
  498.   BEGIN
  499.     IF proc^.class = Module THEN
  500.       IF l <> 0 THEN FixLink(l) END;
  501.     ELSE  (* Proc *)
  502.       IF proc^.typ <> notyp THEN GenHalt(2) END; (* function *)
  503.       IF l <> 0 THEN FixLink(l) END;
  504.       Unlink(proc^.pd^.size, proc^.pd^.lev);
  505.     END;
  506.   END GenReturn;
  507.  
  508.   PROCEDURE GenCase1(VAR x: Item; VAR l0: CARDINAL);
  509.   BEGIN
  510.     SRTest(x);
  511.     IF (x.typ^.form = Undef) OR (x.typ^.form > Enum) THEN
  512.       err(140);  (* illegal type of case expression *)
  513.     END;
  514.     LoadX(x, word); ReleaseReg(x.R); l0 := 0; GenFJ(l0); sp := sp + 4;
  515.   END GenCase1;
  516.  
  517.   PROCEDURE GenCase2;
  518.   BEGIN
  519.     ExitCase;
  520.   END GenCase2;
  521.  
  522.   PROCEDURE GenCase3(VAR x: Item; l0, l1, n: CARDINAL;
  523.                      VAR tab: ARRAY OF LabelRange);
  524.     VAR i: CARDINAL; base, j: INTEGER;
  525.   BEGIN
  526.     base := pc + 2; Put16(VAL(INTEGER,l1) - base);  (* ELSE entry *)
  527.     IF n > 0 THEN (* if NOT empty CASE statement *)
  528.       i := 0; j := tab[0].low;
  529.       WHILE i < n DO
  530.         WHILE j < tab[i].low DO
  531.           Put16(VAL(INTEGER,l1) - base); INC(j);    (* ELSE entry *)
  532.         END;
  533.         FOR j := j TO tab[i].high DO
  534.           Put16(VAL(INTEGER,tab[i].label) - base);
  535.         END;
  536.         INC(i);
  537.       END;
  538.       fixup(l0); EnterCase(x, base, tab[0].low, tab[n-1].high);
  539.     ELSE
  540.       fixup(l0); EnterCase(x, l1, 1, 0); (* if empty CASE statement *)
  541.     END;
  542.     sp := sp - 4;
  543.   END GenCase3;
  544.  
  545.   PROCEDURE GenFor1(v: Item; VAR e1: Item);
  546.   BEGIN
  547.     SRTest(v);
  548.     IF (v.typ^.form = Undef) OR (v.typ^.form > Enum) THEN
  549.       err(142);  (* illegal type of control variable *)
  550.     END;
  551.   END GenFor1;
  552.  
  553.   PROCEDURE GenFor2(v: Item; VAR e1, e2: Item);
  554.     VAR w: Item;
  555.   BEGIN
  556.     IF e2.mode <> conMd THEN LoadD(e2) END;
  557.     GenAssign(v, e1); SRTest(e2); SRTest(v);
  558.     IF e2.typ = cardinttyp THEN e2.typ := v.typ END;
  559.     IF (v.typ = e2.typ) OR (v.typ = inttyp) & (e2.typ = cardtyp) &
  560.        (e2.mode = conMd) & (e2.val.C <= MaxInt) THEN
  561.       IF e2.mode <> conMd THEN
  562.         SetstkMd(w, e2.typ); GenAssign(w, e2);
  563.         e2 := w; e2.mode := RindMd; (* transform to 'RindMd' *)
  564.         sp := sp + e2.typ^.size;
  565.       END
  566.     ELSE err(117) (* incompatible limit *)
  567.     END;
  568.     Release(e2);
  569.   END GenFor2;
  570.  
  571.   PROCEDURE GenFor3(v: Item; VAR e2, e3: Item; VAR l0, l1: CARDINAL);
  572.     VAR f: StrForm; c: Condition;
  573.   BEGIN
  574.     SRTest(v);
  575.     f := v.typ^.form; l0 := pc; Cmp2(v, e2); Release(v);
  576.     (* step must be a constant of type INTEGER/CARDINAL. *)
  577.     IF (e3.typ # inttyp) & (e3.typ # cardtyp) THEN
  578.       err(117) (* illegal type for step *)
  579.     END;
  580.     (* Note the 'dangerous' Add2(v,e3) below ! *)
  581.     IF ((f = Bool) OR (f = Char) OR (f = Enum)) &
  582.        (ABS(WordVal(e3)) # 1) THEN
  583.       err(138) (* illegal value for step *)
  584.     END;
  585.     IF WordVal(e3) > 0 THEN
  586.       IF f = Int THEN c := GT ELSE c := HI END;
  587.     ELSIF WordVal(e3) < 0 THEN
  588.       IF f = Int THEN c := LT ELSE c := CS END;
  589.     ELSE
  590.       err(141) (* step must not be 0 *)
  591.     END;
  592.     l1 := 0; Jf(c, l1);
  593.   END GenFor3;
  594.  
  595.   PROCEDURE GenFor4(v: Item; VAR e2, e3: Item; l0, l1: CARDINAL);
  596.     VAR c: Condition; chk: BOOLEAN;
  597.   BEGIN
  598.     SRTest(v);
  599.     chk := ovflchk; ovflchk := FALSE; Add2(v, e3); ovflchk := chk; Release(v);
  600.     IF v.typ^.form = Int THEN
  601.       c := VC;
  602.     ELSIF WordVal(e3) > 0 THEN
  603.       c := CC;
  604.     ELSE
  605.       c := CS;
  606.     END;
  607.     Jb(c, l0); fixup(l1);
  608.     IF e2.mode <> conMd THEN
  609.       StackTop(2); IF sp >= e2.typ^.size THEN sp := sp - e2.typ^.size END;
  610.     END;
  611.   END GenFor4;
  612.  
  613.   PROCEDURE GenLoop1(VAR s, m: CARDINAL; n: CARDINAL);
  614.   BEGIN
  615.     s := sp0; sp0 := sp; m := n;
  616.   END GenLoop1;
  617.  
  618.   PROCEDURE GenLoop2(s, m: CARDINAL; VAR n: CARDINAL; VAR tab: ExitTable);
  619.   BEGIN
  620.     WHILE n > m DO fixup(tab[n-1]); n := n - 1 END;
  621.     sp0 := s;
  622.   END GenLoop2;
  623.  
  624.   PROCEDURE GenExit(VAR n: CARDINAL; VAR tab: ExitTable);
  625.   BEGIN
  626.     StackTop(sp - sp0);
  627.     IF n <= MaxExit THEN
  628.       tab[n] := 0; GenFJ(tab[n]); INC(n);
  629.     ELSE
  630.       err(93);  (* too many exit statements *)
  631.     END;
  632.   END GenExit;
  633.  
  634.   PROCEDURE GenEnterMod(modList: ObjPtr; mno, pno: CARDINAL);
  635.     VAR obj: ObjPtr; i: CARDINAL;
  636.   BEGIN
  637.     EnterModule;
  638.     maxP := pno + 1;  (* 1 for initialization *)
  639.     maxM := mno + 1;  (* 1 for System *)
  640.     sp := 0; sp0 := 0;
  641.     FOR i := 2 TO maxM DO InitModule(i-1) END;
  642.   END GenEnterMod;
  643.  
  644.   PROCEDURE GenExitMod;
  645.   BEGIN
  646.     ExitModule;
  647.   END GenExitMod;
  648.  
  649. END M2CM. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  650.